home *** CD-ROM | disk | FTP | other *** search
/ Internet Surfer: Getting Started / Internet Surfer - Getting Started (Wayzata Technology)(7231)(1995).bin / pc / mac / bonus / peter_le / macbinar / macbinar.p < prev    next >
Text File  |  1992-12-06  |  19KB  |  772 lines
  1. program MacBinary2Plus;
  2.  
  3.     uses
  4.         Tasks, AppleEvents, MyTypes, MyAppleEvents, MyMemory, MyMacBinary, {}
  5.         CRCs, MyDesktopDB, MyFDFlags, Displays;
  6.  
  7.     const
  8.         macbin_creator = 'MB2P';
  9.         macbin_ftype = 'TEXT';
  10.         errFormatError = -5;
  11.         abortError = 3;
  12.         clear_flags = fdLocked + fdInvisible;
  13.  
  14.     var
  15.         quitNow, quitWhenDone, launchedwithoption: boolean;
  16.         has_AppleEvents: boolean;
  17.         files: integer;
  18.  
  19.     procedure DoQuit;
  20.     begin
  21.         quitNow := true;
  22.     end;
  23.  
  24.     function DoOApp: OSErr;
  25.     begin
  26.         quitNow := true;
  27.         DoOApp := noErr;
  28.     end;
  29.  
  30.     procedure Yield;
  31.         var
  32.             oe: OSErr;
  33.     begin
  34.         oe := TaskYield;
  35.     end;
  36.  
  37.     procedure FailError (oe: OSErr);
  38.         var
  39.             s: str255;
  40.             a: integer;
  41.     begin
  42.         if oe <> abortError then begin
  43.             NumToString(oe, s);
  44.             ParamText(s, '', '', '');
  45.             a := Alert(128, nil);
  46.         end;
  47.     end;
  48.  
  49.     procedure SetSFFile (fs: FSSpec);
  50.     begin
  51.         integerP(SFSaveDiskA)^ := -fs.vRefNum;
  52.         longIntP(CurDirStoreA)^ := fs.parID;
  53.     end;
  54.  
  55.     function GetOutput (var fs: FSSpec): boolean;
  56.         var
  57.             reply: StandardFileReply;
  58.     begin
  59.         SetSFFile(fs);
  60.         StandardPutFile('Save file/folder:', fs.name, reply);
  61.         fs := reply.sfFile;
  62.         GetOutput := reply.sfGood;
  63.     end;
  64.  
  65.     procedure SanitizeName (var name: string);
  66.         var
  67.             i: integer;
  68.     begin
  69.         for i := 1 to length(name) do
  70.             if name[i] in [nul, ':'] then
  71.                 name[i] := '-';
  72.         if (length(name) > 0) & (name[1] = '.') then
  73.             name[1] := 'Ñ';
  74.     end;
  75.  
  76.     function CreateUniqueFile (var fs: FSSPec; creator, ftype: OSType): OSErr;
  77. { Try fs.name }
  78. { Otherwise, try fs.name#index until it succeeds (or fails for another reason) }
  79.         var
  80.             oname: str31;
  81.             n: str255;
  82.             i: integer;
  83.             oe: OSErr;
  84.     begin
  85.         SanitizeName(fs.name);
  86.         oname := fs.name;
  87.         oe := FSpCreate(fs, creator, ftype, 0);
  88.         i := 1;
  89.         while oe = dupFNErr do begin
  90.             NumToString(i, n);
  91.             fs.name := concat(copy(oname, 1, 27), '#', n);
  92.             oe := FSpCreate(fs, creator, ftype, 0);
  93.             i := i + 1;
  94.         end;
  95.         CreateUniqueFile := oe;
  96.     end;
  97.  
  98.     function CreateUniqueDir (var fs: FSSPec; var dirID: longInt): OSErr;
  99. { Try fs.name }
  100. { Otherwise, try fs.name#index until it succeeds (or fails for another reason) }
  101.         var
  102.             oname: str31;
  103.             n: str255;
  104.             i: integer;
  105.             oe: OSErr;
  106.     begin
  107.         SanitizeName(fs.name);
  108.         oname := fs.name;
  109.         oe := FSpDirCreate(fs, 0, dirID);
  110.         i := 1;
  111.         while oe = dupFNErr do begin
  112.             NumToString(i, n);
  113.             fs.name := concat(copy(oname, 1, 27), '#', n);
  114.             oe := FSpDirCreate(fs, 0, dirID);
  115.             i := i + 1;
  116.         end;
  117.         CreateUniqueDir := oe;
  118.     end;
  119.  
  120.     function MyFSWrite (rn: integer; count: longInt; p: ptr): OSErr;
  121.         var
  122.             oe: OSErr;
  123.             c: longInt;
  124.     begin
  125.         c := count;
  126.         oe := FSWrite(rn, c, p);
  127.         if (oe = noErr) & (count <> c) then
  128.             oe := -1;
  129.         MyFSWrite := oe;
  130.     end;
  131.  
  132.     function MyFSRead (rn: integer; count: longInt; p: ptr): OSErr;
  133.         var
  134.             oe: OSErr;
  135.             c: longInt;
  136.     begin
  137.         c := count;
  138.         oe := FSRead(rn, c, p);
  139.         if (oe = noErr) & (count <> c) then
  140.             oe := -1;
  141.         MyFSRead := oe;
  142.     end;
  143.  
  144. { WARNING: Beware of overuse of records pb, fs, start, comment, and header.  This is a recursive routine }
  145. { so I am ver frugal on stack usage, and consiquently, its very dangerous - tread lightly }
  146. { The same it true for endblock and zeropacket, but since they are static it doesnt matter so much }
  147.     procedure DecodeFile (rn: integer; var fs: FSSpec; dtrn: integer; bufferp: ptr; bufsiz: longInt);
  148.         const
  149.             errEndBlock = 2;
  150.         var
  151.             pb: CInfoPBRec;
  152.             start: MBIIStartHeader;
  153.             comment: str255;
  154.             header: MBIIHeader;
  155.             inafolder: boolean;
  156.             clearflags: integer;
  157.         function DF: OSErr;
  158.             function ReadPad (count: longInt): OSErr;
  159.                 var
  160.                     oe: OSErr;
  161.                     space: MBIIHeader;
  162.             begin
  163.                 oe := noErr;
  164.                 count := count mod 128;
  165.                 if count > 0 then begin
  166.                     count := 128 - count;
  167.                     oe := MyFSRead(rn, count, @space);
  168.                     display_done := display_done + count;
  169.                 end;
  170.                 ReadPad := oe;
  171.             end;
  172.  
  173.             function ReadComment (len: integer): OSErr;
  174.                 var
  175.                     oe: OSErr;
  176.             begin
  177.                 if len = 0 then
  178.                     oe := noErr
  179.                 else
  180.                     oe := MyFSRead(rn, len, @comment[1]);
  181.                 display_done := display_done + len;
  182.                 if oe = noErr then
  183.                     oe := ReadPad(len);
  184.                 ReadComment := oe;
  185.             end;
  186.  
  187.             function DoFile: OSErr;
  188.                 function ReadFork (orn: integer; len: longInt): OSErr;
  189.                     var
  190.                         oe: OSErr;
  191.                         olen, count: longInt;
  192.                 begin
  193.                     oe := noErr;
  194.                     olen := len;
  195.                     while (oe = noErr) & (len > 0) do begin
  196.                         count := len;
  197.                         if count > bufsiz then
  198.                             count := bufsiz;
  199.                         Yield;
  200.                         oe := MyFSRead(rn, count, bufferp);
  201.                         display_done := display_done + count;
  202.                         if oe = noErr then
  203.                             oe := MyFSWrite(orn, count, bufferp);
  204.                         len := len - count;
  205.                     end;
  206.                     if oe = noErr then
  207.                         oe := ReadPad(olen);
  208.                     ReadFork := oe;
  209.                 end;
  210.                 var
  211.                     i, orn: integer;
  212.                     count: longInt;
  213.                     oe, ooe: OSErr;
  214.             begin
  215.                 fs.name := start.name;
  216.  
  217.                 oe := noErr;
  218.                 if not inafolder and launchedwithoption then begin
  219.                     if not GetOutput(fs) then
  220.                         oe := abortError;
  221.                 end;
  222.                 if oe = noErr then
  223.                     oe := CreateUniqueFile(fs, start.fcreator, start.ftype);
  224.  
  225.                 if start.dlen > 0 then begin
  226.                     oe := FSpOpenDF(fs, fsRdWrPerm, orn);
  227.                     if oe = noErr then begin
  228.                         oe := ReadFork(orn, start.dlen);
  229.                         ooe := FSClose(orn);
  230.                     end;
  231.                 end;
  232.  
  233.                 if (oe = noErr) and (start.rlen > 0) then begin
  234.                     oe := FSpOpenRF(fs, fsRdWrPerm, orn);
  235.                     if oe = noErr then begin
  236.                         oe := ReadFork(orn, start.rlen);
  237.                         ooe := FSClose(orn);
  238.                     end;
  239.                 end;
  240.  
  241.                 Yield;
  242.  
  243.                 if oe = noErr then
  244.                     oe := ReadComment(start.clen);
  245.                 if oe = noErr then
  246.                     SetDTDBComment(dtrn, fs, comment);
  247.  
  248.                 if oe = noErr then begin
  249.                     pb.ioNamePtr := @fs.name;
  250.                     pb.ioVRefNum := fs.vRefNum;
  251.                     pb.ioFDirIndex := 0;
  252.                     pb.ioDirID := fs.parID;
  253.                     ooe := PBGetCatInfo(@pb, false);
  254.                     if ooe = noErr then begin
  255.                         pb.ioNamePtr := @fs.name;
  256.                         pb.ioVRefNum := fs.vRefNum;
  257.                         pb.ioFDirIndex := 0;
  258.                         pb.ioDirID := fs.parID;
  259.                         pb.ioFlFndrInfo.fdType := start.ftype;
  260.                         pb.ioFlFndrInfo.fdCreator := start.fcreator;
  261.                         pb.ioFlFndrInfo.fdFlags := BOR(BAND(BSL(start.flags_high, 8), $FF00), BAND(start.flags_low, $00FF));
  262.                         pb.ioFlFndrInfo.fdFlags := BXOR(BOR(pb.ioFlFndrInfo.fdFlags, clearflags), clearflags);
  263.                         if inafolder then
  264.                             pb.ioFlFndrInfo.fdLocation := start.flocation;
  265.                         pb.ioFlCrDat := start.create_date;
  266.                         pb.ioFlMdDat := start.mod_date;
  267.                         ooe := PBSetCatInfo(@pb, false);
  268.                     end;
  269.                 end;
  270.  
  271.                 DoFile := oe;
  272.             end;
  273.  
  274.             function DoFolder: OSErr;
  275.                 var
  276.                     ocrc, i, irn: integer;
  277.                     count: longInt;
  278.                     oe, ooe: OSErr;
  279.                     index, vrn: integer;
  280.                     dirID: longInt;
  281.             begin
  282.                 fs.name := start.name;
  283.                 vrn := fs.vRefNum;
  284.                 oe := noErr;
  285.                 if not inafolder and launchedwithoption then begin
  286.                     if not GetOutput(fs) then
  287.                         oe := abortError;
  288.                 end;
  289.                 if oe = noErr then
  290.                     oe := CreateUniqueDir(fs, dirID);
  291.  
  292.                 if oe = noErr then
  293.                     oe := ReadComment(start.clen);
  294.                 if oe = noErr then
  295.                     SetDTDBComment(dtrn, fs, comment);
  296.  
  297.                 if oe = noErr then begin
  298.                     pb.ioNamePtr := @fs.name;
  299.                     pb.ioVRefNum := fs.vRefNum;
  300.                     pb.ioFDirIndex := 0;
  301.                     pb.ioDirID := fs.parID;
  302.                     ooe := PBGetCatInfo(@pb, false);
  303.                     if ooe = noErr then begin
  304.                         pb.ioNamePtr := @fs.name;
  305.                         pb.ioVRefNum := fs.vRefNum;
  306.                         pb.ioFDirIndex := 0;
  307.                         pb.ioDirID := fs.parID;
  308.                         pb.ioFlFndrInfo.fdFlags := BOR(BAND(BSL(start.flags_high, 8), $FF00), BAND(start.flags_low, $00FF));
  309.                         pb.ioFlFndrInfo.fdFlags := BXOR(BOR(pb.ioFlFndrInfo.fdFlags, clearflags), clearflags);
  310.                         if inafolder then
  311.                             pb.ioFlFndrInfo.fdLocation := start.flocation;
  312.                         pb.ioFlCrDat := start.create_date;
  313.                         pb.ioFlMdDat := start.mod_date;
  314.                         ooe := PBSetCatInfo(@pb, false);
  315.                     end;
  316.                 end;
  317.                 inafolder := true;
  318.                 clearflags := clear_flags;
  319.  
  320.                 if oe = noErr then begin
  321.                     repeat
  322.                         fs.vRefNum := vrn;
  323.                         fs.parID := dirID;
  324.                         oe := DF;
  325.                     until (oe <> noErr);
  326.                     if oe = errEndBlock then
  327.                         oe := noErr;
  328.                 end;
  329.  
  330.                 DoFolder := oe;
  331.             end;
  332.             var
  333.                 oe: OSErr;
  334.                 typ: packet_type;
  335.         begin
  336.             oe := MyFSRead(rn, SizeOf(header), @header);
  337.             display_done := display_done + SizeOf(header);
  338.             BlockMove(@header.MBIIStart, @start, SizeOf(start));
  339.             if oe = noErr then
  340.                 typ := ValidateMBHeader(header, true)
  341.             else
  342.                 typ := PT_None;
  343.             case typ of
  344.                 PT_File: 
  345.                     oe := DoFile;
  346.                 PT_StartBlock: 
  347.                     oe := DoFolder;
  348.                 PT_EndBlock: 
  349.                     oe := errEndBlock;
  350.                 otherwise
  351.                     oe := errFormatError;
  352.             end;
  353.             DF := oe;
  354.         end;
  355.         var
  356.             oe: OSErr;
  357.             len: longInt;
  358.     begin
  359.         inafolder := false;
  360.         clearflags := clear_flags + fdInited;
  361.         oe := GetEOF(rn, len);
  362.         if oe = noErr then
  363.             display_total := display_total + len;
  364.         oe := DF;
  365.         if oe <> noErr then
  366.             FailError(oe);
  367.     end;
  368.  
  369. { WARNING: Beware of overuse of records pb, fs, start, comment, and header.  This is a recursive routine }
  370. { so I am very frugal on stack usage, and consiquently, its very dangerous - tread lightly }
  371. { The same it true for endblock and zeropacket, but since they are static it doesnt matter so much }
  372.     function EncodeToFile (var pb: CInfoPBRec; var fs: FSSpec; rn, dtrn: integer; bufferp: ptr; bufsiz: longInt): OSErr;
  373.         const
  374.             display_folder_size = 1000;
  375.         var
  376.             start: MBIIStartHeader;
  377.             comment: str255;
  378.             header: MBIIHeader;
  379.             endblock: MBIIHeader;
  380.             zeropacket: MBpacket;
  381.         function ETF: OSErr;
  382.             function WritePad (count: longInt): OSErr;
  383.                 var
  384.                     oe: OSErr;
  385.             begin
  386.                 oe := noErr;
  387.                 count := count mod 128;
  388.                 if count > 0 then begin
  389.                     count := 128 - count;
  390.                     oe := MyFSWrite(rn, count, @zeropacket);
  391.                 end;
  392.                 WritePad := oe;
  393.             end;
  394.  
  395.             function WriteComment: OSErr;
  396.                 var
  397.                     count: longInt;
  398.                     oe: OSErr;
  399.             begin
  400.                 count := length(comment);
  401.                 oe := MyFSWrite(rn, count, @comment[1]);
  402.                 if oe = noErr then
  403.                     oe := WritePad(count);
  404.                 WriteComment := oe;
  405.             end;
  406.  
  407.             function DoFile: OSErr;
  408.                 function WriteFork (irn: integer; len: longInt): OSErr;
  409.                     var
  410.                         oe: OSErr;
  411.                         olen, count: longInt;
  412.                 begin
  413.                     oe := noErr;
  414.                     olen := len;
  415.                     while (oe = noErr) & (len > 0) do begin
  416.                         Yield;
  417.                         count := len;
  418.                         if count > bufsiz then
  419.                             count := bufsiz;
  420.                         oe := MyFSRead(irn, count, bufferp);
  421.                         if oe = noErr then
  422.                             oe := MyFSWrite(rn, count, bufferp);
  423.                         display_done := display_done + count;
  424.                         len := len - count;
  425.                     end;
  426.                     if oe = noErr then
  427.                         oe := WritePad(olen);
  428.                     WriteFork := oe;
  429.                 end;
  430.                 var
  431.                     ocrc, i, irn: integer;
  432.                     count: longInt;
  433.                     oe, ooe: OSErr;
  434.             begin
  435.                 fs.vRefNum := pb.ioVRefNum;
  436.                 fs.parID := pb.ioFlParID;
  437.                 fs.name := pb.ioNamePtr^;
  438.                 MFillLong(@header, SizeOf(header), 0);
  439.                 MFill(@start, SizeOf(start), 0);
  440.                 header.versionII := 129;
  441.                 header.minversionII := 129;
  442.                 start.name := fs.name;
  443.                 start.ftype := pb.ioFlFndrInfo.fdType;
  444.                 start.fcreator := pb.ioFlFndrInfo.fdCreator;
  445.                 start.flags_high := BAND(BSR(pb.ioFlFndrInfo.fdFlags, 8), $FF);
  446.                 start.flags_low := BAND(pb.ioFlFndrInfo.fdFlags, $FF);
  447.                 start.flocation := pb.ioFlFndrInfo.fdLocation;
  448.                 start.windowID := pb.ioFlFndrInfo.fdFldr;
  449.                 start.dlen := pb.ioFlLgLen;
  450.                 start.rlen := pb.ioFlRLgLen;
  451.                 start.create_date := pb.ioFlCrDat;
  452.                 start.mod_date := pb.ioFlMdDat;
  453.                 GetDTDBComment(dtrn, fs, comment);
  454.                 start.clen := length(comment);
  455.                 BlockMove(@start, @header.MBIIStart, SizeOf(start));
  456.                 ocrc := 0;
  457.                 for i := 1 to 124 do
  458.                     CalcMBCRC(ocrc, MBPacket(header)[i]);
  459.                 header.crc := ocrc;
  460.                 count := SizeOf(header);
  461.                 oe := MyFSWrite(rn, count, @header);
  462.                 Yield;
  463.                 if oe = noErr then begin
  464.                     oe := FSpOpenDF(fs, fsRdPerm, irn);
  465.                     if oe = noErr then begin
  466.                         oe := WriteFork(irn, pb.ioFlLgLen);
  467.                         ooe := FSClose(irn);
  468.                         if oe = noErr then
  469.                             oe := FSpOpenRF(fs, fsRdPerm, irn);
  470.                         if oe = noErr then begin
  471.                             oe := WriteFork(irn, pb.ioFlRLgLen);
  472.                             ooe := FSClose(irn);
  473.                             Yield;
  474.                             oe := WriteComment;
  475.                         end;
  476.                     end;
  477.                 end;
  478.                 DoFile := oe;
  479.             end;
  480.  
  481.             function DoFolder: OSErr;
  482.                 var
  483.                     ocrc, i, irn: integer;
  484.                     count: longInt;
  485.                     oe, ooe: OSErr;
  486.                     index, vrn: integer;
  487.                     dirID: longInt;
  488.             begin
  489.                 fs.vRefNum := pb.ioVRefNum;
  490.                 fs.parID := pb.ioDrDirID;
  491.                 fs.name := pb.ioNamePtr^;
  492.                 MFillLong(@header, SizeOf(header), 0);
  493.                 MFill(@start, SizeOf(start), 0);
  494.                 header.version := 1;
  495.                 header.versionII := 130;
  496.                 header.minversionII := 130;
  497.                 start.name := fs.name;
  498.                 start.ftype := macbin_folder_ftype;
  499.                 start.fcreator := OSType(macbin_folder_creator_start);
  500.                 start.flags_high := BAND(BSR(pb.ioFlFndrInfo.fdFlags, 8), $FF);
  501.                 start.flags_low := BAND(pb.ioFlFndrInfo.fdFlags, $FF);
  502.                 start.flocation := pb.ioFlFndrInfo.fdLocation;
  503.                 start.windowID := pb.ioFlFndrInfo.fdFldr;
  504.                 start.dlen := 0;
  505.                 start.rlen := 0;
  506.                 start.create_date := pb.ioFlCrDat;
  507.                 start.mod_date := pb.ioFlMdDat;
  508.                 GetDTDBComment(dtrn, fs, comment);
  509.                 start.clen := length(comment);
  510.                 BlockMove(@start, @header.MBIIStart, SizeOf(start));
  511.                 ocrc := 0;
  512.                 for i := 1 to 124 do
  513.                     CalcMBCRC(ocrc, MBPacket(header)[i]);
  514.                 header.crc := ocrc;
  515.                 count := SizeOf(header);
  516.                 oe := MyFSWrite(rn, count, @header);
  517.                 if oe = noErr then
  518.                     oe := WriteComment;
  519.                 Yield;
  520.                 if oe = nOErr then begin
  521.                     index := 1;
  522.                     dirID := pb.ioDirID;
  523.                     vrn := pb.ioVRefNum;
  524.                     repeat
  525.                         fs.name := '';
  526.                         pb.ioNamePtr := @fs.name;
  527.                         pb.ioVRefNum := vrn;
  528.                         pb.ioFDirIndex := index;
  529.                         index := index + 1;
  530.                         pb.ioDirID := dirID;
  531.                         oe := PBGetCatInfo(@pb, false);
  532.                         if oe = fnfErr then begin
  533.                             oe := noErr;
  534.                             leave;
  535.                         end;
  536.                         if oe = noErr then
  537.                             oe := ETF;
  538.                     until oe <> noErr;
  539.                     if oe = noErr then begin
  540.                         count := SizeOf(endblock);
  541.                         oe := MyFSWrite(rn, count, @endblock);
  542.                     end;
  543.                     display_done := display_done + display_folder_size;
  544.                 end;
  545.                 DoFolder := oe;
  546.             end;
  547.         begin
  548.             if BAND(pb.ioFlAttrib, $0010) = 0 then begin
  549.                 ETF := DoFile;
  550.             end
  551.             else begin
  552.                 ETF := DoFolder;
  553.             end;
  554.         end;
  555.  
  556.         var
  557.             ppb: CInfoPBRec;
  558.             pname: str63;
  559.         function PreScan: OSErr;
  560.             var
  561.                 oe: OSErr;
  562.                 index, vrn: integer;
  563.                 dirID: longInt;
  564.         begin
  565.             if BAND(ppb.ioFlAttrib, $0010) = 0 then begin
  566.                 display_total := display_total + ppb.ioFlLgLen + ppb.ioFlRLgLen;
  567.                 oe := noErr;
  568.             end
  569.             else begin
  570.                 Yield;
  571.                 display_total := display_total + display_folder_size;
  572.                 index := 1;
  573.                 dirID := ppb.ioDirID;
  574.                 vrn := ppb.ioVRefNum;
  575.                 repeat
  576.                     pname := '';
  577.                     ppb.ioNamePtr := @pname;
  578.                     ppb.ioVRefNum := vrn;
  579.                     ppb.ioFDirIndex := index;
  580.                     index := index + 1;
  581.                     ppb.ioDirID := dirID;
  582.                     oe := PBGetCatInfo(@ppb, false);
  583.                     if oe = fnfErr then begin
  584.                         oe := noErr;
  585.                         leave;
  586.                     end;
  587.                     if oe = noErr then
  588.                         oe := PreScan;
  589.                 until oe <> noErr;
  590.             end;
  591.             PreScan := oe;
  592.         end;
  593.  
  594.         var
  595.             i, ocrc: integer;
  596.             oe: OSErr;
  597.     begin
  598.         MFillLong(@zeropacket, SizeOf(zeropacket), 0); { used for padding }
  599.         MFillLong(@endblock, SizeOf(endblock), 0);
  600.         MFill(@start, SizeOf(start), 0);
  601.         endblock.version := 1;
  602.         start.ftype := macbin_folder_ftype;
  603.         start.fcreator := OSType(macbin_folder_creator_end);
  604.         BlockMove(@start, @endblock.MBIIStart, SizeOf(start));
  605.         endblock.versionII := 130;
  606.         endblock.minversionII := 130;
  607.         ocrc := 0;
  608.         for i := 1 to 124 do
  609.             CalcMBCRC(ocrc, MBPacket(endblock)[i]);
  610.         endblock.crc := ocrc;
  611.         ppb := pb;
  612.         oe := PreScan; { Sigh, I hate progress bars! }
  613.         EncodeToFile := ETF;
  614.     end;
  615.  
  616.     procedure EncodeFileFolder (var pb: CInfoPBRec; var fs: FSSpec; dtrn: integer; bufferp: ptr; bufsiz: longInt);
  617.         var
  618.             dst: FSSpec;
  619.             rn: integer;
  620.             oe, ooe: OSErr;
  621.             doit: boolean;
  622.     begin
  623.         oe := noErr;
  624.         doit := true;
  625.         dst := fs;
  626.         if copy(dst.name, length(dst.name) - 2, 2) = ' ─' then
  627.             dst.name := copy(dst.name, 1, length(dst.name) - 2);
  628.         dst.name := concat(dst.name, '.bin');
  629.         if launchedwithoption then begin
  630.             doit := GetOutput(dst);
  631.         end;
  632.         if doit then begin
  633.             oe := CreateUniqueFile(dst, macbin_creator, macbin_ftype);
  634.             if oe = noErr then begin
  635.                 oe := FSpOpenDF(dst, fsRdWrPerm, rn);
  636.                 if oe = noErr then begin
  637.                     oe := EncodeToFile(pb, fs, rn, dtrn, bufferp, bufsiz);
  638.                     ooe := FSClose(rn);
  639.                 end;
  640.             end;
  641.         end;
  642.         MDisposePtr(bufferp);
  643.         if oe <> noErr then
  644.             FailError(oe);
  645.     end;
  646.  
  647.     procedure CheckFile (var pb: CInfoPBRec; var fs: FSSpec; dtrn: integer; bufferp: ptr; bufsiz: longInt);
  648.         var
  649.             isbin: boolean;
  650.             rn: integer;
  651.             oe, ooe: OSErr;
  652.             header: MBIIHeader;
  653.             count: longInt;
  654.     begin
  655.         isbin := false;
  656.         if (pb.ioFlLgLen > 128) then begin
  657.             oe := FSpOpenDF(fs, fsRdPerm, rn);
  658.             if oe = noErr then begin
  659.                 oe := MyFSRead(rn, SizeOf(header), @header);
  660.                 if (oe = noErr) & (ValidateMBHeader(header, true) <> PT_None) then begin
  661.                     oe := SetFPos(rn, fsFromStart, 0);
  662.                     if oe = noErr then begin
  663.                         DecodeFile(rn, fs, dtrn, bufferp, bufsiz);
  664.                     end;
  665.                     isbin := true;
  666.                 end;
  667.                 oe := FSClose(rn);
  668.             end;
  669.         end;
  670.  
  671.         if not isbin then
  672.             EncodeFileFolder(pb, fs, dtrn, bufferp, bufsiz);
  673.     end;
  674.  
  675.     procedure DoFile (fsp: FSSpecPtr);
  676.         var
  677.             dst: FSSPec;
  678.             pb: CInfoPBRec;
  679.             oe: OSErr;
  680.             dtrn: integer;
  681.             bufferp: ptr;
  682.             bufsiz, t: longInt;
  683.     begin
  684.         files := files + 1;
  685.         quitWhenDone := true;
  686.         quitNow := true;
  687.  
  688.         oe := GetDesktopDB(fsp^.vRefNum, dtrn); { ignore error }
  689.         PurgeSpace(t, bufsiz);
  690.         bufsiz := bufsiz div 3;
  691.         MNewPtr(bufferp, bufsiz);
  692.         oe := MemError;
  693.         if bufferp <> nil then begin
  694.             with pb do begin
  695.                 ioNamePtr := @fsp^.name;
  696.                 ioVRefNum := fsp^.vRefNum;
  697.                 ioDirID := fsp^.parID;
  698.                 ioFDirIndex := 0;
  699.             end;
  700.             oe := PBGetCatInfo(@pb, false);
  701.             if oe = noErr then begin
  702.                 if BAND(pb.ioFlAttrib, $0010) = 0 then
  703.                     CheckFile(pb, fsp^, dtrn, bufferp, bufsiz)
  704.                 else begin
  705.                     EncodeFileFolder(pb, fsp^, dtrn, bufferp, bufsiz);
  706.                 end;
  707.             end;
  708.         end;
  709.  
  710.         files := files - 1;
  711.         MDisposePtr(fsp);
  712.     end;
  713.  
  714.     function DoODoc (fs: FSSpec): OSErr;
  715.         var
  716.             trn: integer;
  717.             p: FSSpecPtr;
  718.             oe: OSErr;
  719.     begin
  720.         MNewPtr(p, SizeOf(FSSpec));
  721.         oe := MemError;
  722.         if p <> nil then begin
  723.             p^ := fs;
  724.             oe := NewTask(@DoFile, nil, p, trn);
  725.         end;
  726.         DoODoc := oe;
  727.     end;
  728.  
  729.     var
  730.         oe, ooe: OSErr;
  731.         gv: longInt;
  732.         er: eventRecord;
  733.         dummy: boolean;
  734. begin
  735.     dummy := OSEventAvail(everyEvent, er);
  736.     launchedwithoption := BAND(er.modifiers, optionKey) <> 0;
  737.     oe := Gestalt(gestaltAppleEventsAttr, gv);
  738.     has_AppleEvents := (oe = noErr) and (BTST(gv, gestaltAppleEventsPresent));
  739.     quitNow := false;
  740.     quitWhenDone := false;
  741.     files := 0;
  742.     if has_AppleEvents & (InitAppleEvents(@DOOApp, @DoODoc, nil, @DoQuit) = noErr) then begin
  743.         InitDisplay;
  744.         if InitTasking = noErr then begin
  745.  
  746.             while not quitNow or (quitWhenDone and (files > 0)) do begin
  747.                 if WaitNextEvent(everyEvent, er, 3, nil) then begin
  748.                     case er.what of
  749.                         keyDown: 
  750.                             quitNow := true;
  751.                         updateEvt:  begin
  752.                             BeginUpdate(windowPtr(er.message));
  753.                             UpdateDisplay;
  754.                             EndUpdate(windowPtr(er.message));
  755.                         end;
  756.                         kHighLevelEvent: 
  757.                             if has_AppleEvents then
  758.                                 oe := AEProcessAppleEvent(er);
  759.                         otherwise
  760.                             ;
  761.                     end;
  762.                 end;
  763.         { Allow tasks to run for a while }
  764.                 oe := RunTasks(1);
  765.                 UpdateDisplay;
  766.             end;
  767.  
  768.             ooe := TermTasking;
  769.         end;
  770.         FinishDisplay;
  771.     end;
  772. end.